perm filename NONDAD[TIM,LSP] blob
sn#736740 filedate 1983-12-28 generic text, type T, neo UTF8
(FILECREATED "20-SEP-83 20:31:18" <LISPUSERS>NONDADDARITH.;17 36718
changes to: (FNS \DEPOSITBYTEEXPANDER)
(VARS NONDADDARITHCOMS)
previous date: "20-SEP-83 16:19:08" <LISPUSERS>NONDADDARITH.;13)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT NONDADDARITHCOMS)
(RPAQQ NONDADDARITHCOMS ((FILES MACROAUX)
(LOCALVARS . T)
(DECLARE: EVAL@COMPILE (P (MAPC (QUOTE ((\PTRBLOCK.GCT T)
(BITSPERNIBBLE 4)
(BITSPERBYTE 8)
(BITSPERDOUBLEBYTE 16)
(BITSPERCELL (32 36))))
(FUNCTION (LAMBDA (Y)
(PROG ((X (CAR Y))
(VALUE (CADR Y)))
(AND (LISTP VALUE)
(SETQ
VALUE
(SELECTQ (SYSTEMTYPE)
(VAX (CAR VALUE))
(CADR VALUE))))
(COND
((NEQ VALUE (CAR (
CONSTANTEXPRESSIONP X)))
(SET X VALUE)
(APPLY (FUNCTION CONSTANTS)
(LIST (LIST X VALUE)))))))))
(OR (CONSTANTEXPRESSIONP (QUOTE BITS.PER.FIXP))
(PROGN (SETQ BITS.PER.FIXP BITSPERCELL)
(CONSTANTS BITS.PER.FIXP)))
(OR (CONSTANTEXPRESSIONP (QUOTE MAX.FIXP))
(PROGN (SETQ MAX.FIXP (LOGOR (LLSH 1 (SUB1 BITS.PER.FIXP))
(SUB1 (LLSH 1 (SUB1 BITS.PER.FIXP))
)))
(CONSTANTS MAX.FIXP))))
(DECLARE: DONTCOPY (P (SETQ CLISPIFTRANFLG T))
(MACROS NNLITATOM \MACRO.MX \CHECKTYPE \CHECK.BYTESPEC \INDEXABLE.FIXP)
(RECORDS NONDADDARITHFLONUM)))
(COMS (* Vector functions, and basic new arithmetic functions)
(FNS \MakeVector \VectorREF \VectorSET \VectorLength)
(MACROS \MakeVector \VectorREF \VectorSET \VectorLength)
(PROP GLOBALVAR \RJ1M \MASKOUT.MARGIN)
(MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
(FNS \MASK.1'S.EXPANDER)
(FNS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
(FNS \SETUP.MASKARRAYS)
(RECORDS BYTESPEC)
(FNS LOADBYTE DEPOSITBYTE)
(MACROS LOADBYTE DEPOSITBYTE LDB DPB BYTE BYTESIZE BYTEPOSITION)
(FNS \LDBEXPANDER \DPBEXPANDER \LOADBYTEEXPANDER \DEPOSITBYTEEXPANDER))
(DECLARE: EVAL@COMPILE DONTCOPY (* Grumble lossaged due to failure of (FNS ...)
when merely EVAL@COMPILE)
(FNS \SETUP.MASKARRAYS \MASK.1'S.EXPANDER \LOADBYTEEXPANDER \DEPOSITBYTEEXPANDER))
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DOCOPY (P (\SETUP.MASKARRAYS)))
(COMS (* Primitive functions, especially needed for CommonLisp array package.)
(DECLARE: DONTCOPY
(MACROS \GETBASE \PUTBASE \GETBASEPTR \PUTBASEPTR \GETBASEFIXP \PUTBASEFIXP
\GETBASEFLOATP \PUTBASEFLOATP \GETBASEDOUBLEBYTE \PUTBASEDOUBLEBYTE
\GETBASEBYTE \PUTBASEBYTE \GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT
\PUTBASEBIT))
(FNS \GETBASE \PUTBASE \GETBASEPTR \PUTBASEPTR \GETBASEFIXP \PUTBASEFIXP \GETBASEFLOATP
\PUTBASEFLOATP \GETBASEDOUBLEBYTE \PUTBASEDOUBLEBYTE \GETBASEBYTE \PUTBASEBYTE
\GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT \PUTBASEBIT))))
(FILESLOAD MACROAUX)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: EVAL@COMPILE
(MAPC (QUOTE ((\PTRBLOCK.GCT T)
(BITSPERNIBBLE 4)
(BITSPERBYTE 8)
(BITSPERDOUBLEBYTE 16)
(BITSPERCELL (32 36))))
(FUNCTION (LAMBDA (Y)
(PROG ((X (CAR Y))
(VALUE (CADR Y)))
(AND (LISTP VALUE)
(SETQ VALUE (SELECTQ (SYSTEMTYPE)
(VAX (CAR VALUE))
(CADR VALUE))))
(COND ((NEQ VALUE (CAR (CONSTANTEXPRESSIONP X)))
(SET X VALUE)
(APPLY (FUNCTION CONSTANTS)
(LIST (LIST X VALUE)))))))))
(OR (CONSTANTEXPRESSIONP (QUOTE BITS.PER.FIXP))
(PROGN (SETQ BITS.PER.FIXP BITSPERCELL)
(CONSTANTS BITS.PER.FIXP)))
(OR (CONSTANTEXPRESSIONP (QUOTE MAX.FIXP))
(PROGN (SETQ MAX.FIXP (LOGOR (LLSH 1 (SUB1 BITS.PER.FIXP))
(SUB1 (LLSH 1 (SUB1 BITS.PER.FIXP)))))
(CONSTANTS MAX.FIXP)))
(DECLARE: DONTCOPY
(SETQ CLISPIFTRANFLG T)
(DECLARE: EVAL@COMPILE
(PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X)
(AND X (LITATOM X))))
(PUTPROPS \MACRO.MX MACRO (Z (PROG ((X (EXPANDMACRO (CAR Z)
T)))
(COND
((EQ X (CAR Z))
(ERROR "No macro property -- \MACRO.MX" X))
(T (RETURN X))))))
(PUTPROPS \CHECKTYPE MACRO (X (PROG ((VAR (CAR X))
(PRED (CADR X)))
(if (AND (LISTP PRED)
(MEMB (CAR PRED)
(QUOTE (QUOTE FUNCTION))))
then (SETQ PRED (LIST (CADR PRED)
VAR)))
(RETURN (SUBPAIR (QUOTE (MSG VAR PRED))
(LIST (CONCAT
"
is not a suitable value for the variable: "
VAR)
VAR PRED)
(QUOTE (until PRED do (SETQ VAR
(ERROR VAR MSG)))))))))
(PUTPROPS \CHECK.BYTESPEC MACRO (X
(PROG ((POS (CAR X))
(SIZE (CADR X))
(LENGTHLIMIT (CADDR X))) (* Currently, this macro may only be call with "pos" and
"size" arguments as litatoms, so that they may be "SETQ'd"
in-line.)
(if (NOT (NNLITATOM POS))
then (SETERRORN 14 POS)
(ERRORX)
elseif (NOT (NNLITATOM SIZE))
then (SETERRORN 14 SIZE)
(ERRORX)
elseif (AND LENGTHLIMIT (NOT (LITATOM LENGTHLIMIT)))
then (SETERRORN 14 LENGTHLIMIT)
(ERRORX))
(RETURN (BQUOTE (PROGN (\CHECKTYPE , POS
(AND (\INDEXABLE.FIXP , POS)
,@(AND LENGTHLIMIT
(BQUOTE ((ILEQ , POS , LENGTHLIMIT)))
)))
(\CHECKTYPE , SIZE
(AND (\INDEXABLE.FIXP , SIZE)
,@(AND LENGTHLIMIT
(BQUOTE ((ILEQ (IPLUS , POS , SIZE)
, LENGTHLIMIT)))))))))
)))
(PUTPROPS \INDEXABLE.FIXP MACRO (OPENLAMBDA (X)
(AND (FIXP X)
(IGEQ X 0))))
(PUTPROPS \INDEXABLE.FIXP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0))))
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD NONDADDARITHFLONUM ((FLONUM FLOATP)))
]
)
)
(* Vector functions, and basic new arithmetic functions)
(DEFINEQ
(\MakeVector
(LAMBDA (N) (* JonL "20-SEP-83 13:07")
(PROG ((A (ARRAY (LRSH (IPLUS N 3)
1))))
(SETA A 1 N)
(RETURN A))))
(\VectorREF
(LAMBDA (V I) (* JonL "20-SEP-83 13:15")
(COND
((OR (MINUSP I)
(NOT (ILESSP I (ELT V 1))))
(ERROR I "Index out of bounds"))
((ODDP I)
(ELT V (IPLUS 2 (LRSH I 1))))
(T (ELTD V (IPLUS 2 (LRSH I 1)))))))
(\VectorSET
(LAMBDA (V I VAL) (* JonL "20-SEP-83 13:15")
(COND
((OR (MINUSP I)
(NOT (ILESSP I (ELT V 1))))
(ERROR I "Index out of bounds"))
((ODDP I)
(SETA V (IPLUS 2 (LRSH I 1))
VAL))
(T (SETD V (IPLUS 2 (LRSH I 1))
VAL)))))
(\VectorLength
(LAMBDA (V) (* JonL "20-SEP-83 13:37")
(ELT V 1)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \MakeVector 10MACRO ((N)
((LAMBDA (LEN)
(DECLARE (LOCALVARS LEN))
((LAMBDA (A)
(DECLARE (LOCALVARS A))
(CLOSER (IPLUS (LOC A)
2)
LEN)
A)
(ARRAY (LRSH (IPLUS N 3)
1))))
N)))
(PUTPROPS \VectorREF 10MACRO (OPENLAMBDA (V I)
(VAG (LOADBYTE (OPENR (IPLUS (LOC V)
3
(LRSH I 1)))
(COND ((ODDP I)
0)
(T 18))
18))))
(PUTPROPS \VectorSET 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(* The reason for this kludgy duplication is so that the 10
compiler can open-code the arithmetic)
(CLOSER (IPLUS (LOC BASE)
3
(LRSH OFFST 1))
(COND ((ODDP OFFST)
(DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
3
(LRSH OFFST 1)))
0 18 (LOC VAL)))
(T (DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
3
(LRSH OFFST 1)))
18 18 (LOC VAL)))))
VAL))
(PUTPROPS \VectorLength 10MACRO ((V)
(VAG (OPENR (IPLUS 2 (LOC V))))))
)
(PUTPROPS \RJ1M GLOBALVAR T)
(PUTPROPS \MASKOUT.MARGIN GLOBALVAR T)
(DECLARE: EVAL@COMPILE
(PUTPROPS MASK.1'S MACRO (X (\MASK.1'S.EXPANDER X)))
(PUTPROPS MASK.0'S MACRO (X (PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM) (* This used to have a lot more in it, but I decided
that it really isn't an important function.)
(RETURN (if (AND (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
(SETQ POSITION TEM)
(SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
(SETQ SIZE TEM))
then (MASK.0'S POSITION SIZE)
else (LIST (QUOTE LOGNOT)
(LIST (QUOTE MASK.1'S)
POSITION SIZE)))))))
(PUTPROPS BITTEST MACRO ((N MASK)
(NEQ 0 (LOGAND N MASK))))
(PUTPROPS BITSET MACRO (= . LOGOR))
(PUTPROPS BITCLEAR MACRO ((X MASK)
(LOGAND X (LOGXOR -1 MASK))))
(PUTPROPS LOGNOT MACRO ((N)
(LOGXOR -1 N)))
)
(DEFINEQ
(\MASK.1'S.EXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
then (SETQ POSITION TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
then (SETQ SIZE TEM)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
SIZE))
elseif (ZEROP POSITION)
then (RETURN (LIST (QUOTE \VectorREF)
(QUOTE \RJ1M)
SIZE))))
(RETURN (LIST (QUOTE \VectorREF)
(LIST (QUOTE \VectorREF)
(QUOTE \MASKOUT.MARGIN)
POSITION)
SIZE)))))
)
(DEFINEQ
(MASK.1'S
(LAMBDA (POSITION SIZE) (* JonL "24-OCT-82 18:13")
(* This function restricts it's arguments so that the open-coded expansion is valid for any correct set of
arguments; the open-coding cannot do coercion since the D version just does \GETBASEPTR using the input args as
indices.)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(\MACRO.MX (MASK.1'S POSITION SIZE))))
(MASK.0'S
(LAMBDA (POSITION SIZE) (* JonL "22-OCT-82 21:28")
(* FOO, so this may cons on larger numbers, but probably
this functions isn't all that important.)
(LOGNOT (APPLY* (FUNCTION MASK.1'S)
POSITION SIZE))))
(BITTEST
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:36")
(\MACRO.MX (BITTEST N MASK))))
(BITSET
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:37")
(\MACRO.MX (BITSET N MASK))))
(BITCLEAR
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:36")
(\MACRO.MX (BITCLEAR N MASK))))
(LOGNOT
(LAMBDA (N) (* JonL "24-JUL-82 01:14")
(LOGXOR -1 N)))
)
(DEFINEQ
(\SETUP.MASKARRAYS
(LAMBDA NIL (* JonL "22-JAN-83 22:58")
(* \RJ1M is a Vector of right-justified 1's masks.
\MASKOUT.MARGIN is a 2-dim Vector of 1's masks, in all
possible alignments in a cell.)
(SETQ \RJ1M (\MakeVector (ADD1 BITS.PER.FIXP)))
(\VectorSET \RJ1M BITS.PER.FIXP -1)
(for K from 0 to (PROG1 (SUB1 BITS.PER.FIXP) (* Comment PPLossage)
)
do (\VectorSET \RJ1M K (SUB1 (LLSH 1 K))))
(SETQ \MASKOUT.MARGIN (\MakeVector (ADD1 BITS.PER.FIXP)))
(* Each element of \MASKOUT.MARGIN is a vector of masks,
where increasing indices means increasing start-position
of the mask.)
(\VectorSET \MASKOUT.MARGIN 0 \RJ1M)
(for POS from 1 to BITS.PER.FIXP bind MASKARRAY MAXFIELDSIZE
do (SETQ MAXFIELDSIZE (IDIFFERENCE BITS.PER.FIXP POS))
(SETQ MASKARRAY (\MakeVector (ADD1 MAXFIELDSIZE)))
(for K from 0 to (PROG1 MAXFIELDSIZE (* Comment PPLossage))
do (\VectorSET MASKARRAY K (LLSH (\VectorREF \RJ1M K)
POS)))
(\VectorSET \MASKOUT.MARGIN POS MASKARRAY))))
)
[DECLARE: EVAL@COMPILE
(TYPERECORD BYTESPEC (BYTESPEC.SIZE BYTESPEC.POSITION))
]
(DEFINEQ
(LOADBYTE
(LAMBDA (N POS SIZE) (* JonL "20-SEP-83 15:05")
(\CHECK.BYTESPEC POS SIZE)
(\CHECKTYPE N (FUNCTION FIXP))
(LOGAND (LRSH N POS)
(MASK.1'S 0 (IMIN BITS.PER.FIXP SIZE)))))
(DEPOSITBYTE
(LAMBDA (N POS SIZE VAL) (* JonL "20-SEP-83 15:18")
(* Limits set due to BITS.PER.FIXP are because we can't
create a BIGNUM answer yet.)
(\CHECK.BYTESPEC POS SIZE BITS.PER.FIXP)
(\CHECKTYPE N (QUOTE FIXP))
(LOGOR (BITCLEAR N (LLSH (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE))
POS))
(LLSH (LOGAND VAL (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE)))
POS))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS LOADBYTE MACRO (X (\LOADBYTEEXPANDER X)))
(PUTPROPS DEPOSITBYTE MACRO (X (\DEPOSITBYTEEXPANDER X)))
(PUTPROPS LDB MACRO (X (\LDBEXPANDER X)))
(PUTPROPS DPB MACRO (X (\DPBEXPANDER X)))
(PUTPROPS BYTE MACRO (X (PROG ((SIZE (LISPFORM.SIMPLIFY (CAR X)
T))
(POSITION (LISPFORM.SIMPLIFY (CADR X)
T)))
(RETURN (if (AND (FIXP POSITION)
(FIXP SIZE))
then (KWOTE (create BYTESPEC
BYTESPEC.SIZE ← SIZE
BYTESPEC.POSITION ← POSITION))
else (BQUOTE (create BYTESPEC
BYTESPEC.SIZE ← , SIZE
BYTESPEC.POSITION ← , POSITION)))))))
(PUTPROPS BYTESIZE MACRO ((BYTESPEC)
(fetch BYTESPEC.SIZE of BYTESPEC)))
(PUTPROPS BYTEPOSITION MACRO ((BYTESPEC)
(fetch BYTESPEC.POSITION of BYTESPEC)))
)
(DEFINEQ
(\LDBEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((BS (LISPFORM.SIMPLIFY (CAR X)
T))
(WORD (CADR X))
TEM N SIZE POSITION)
(RETURN (if (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
(type? BYTESPEC TEM))
then (LIST (QUOTE LOADBYTE)
WORD
(KWOTE (BYTEPOSITION TEM))
(KWOTE (BYTESIZE TEM)))
else (SETQ N (LISPFORM.SIMPLIFY WORD T))
(if (AND (LISTP BS)
(EQ (CAR BS)
(QUOTE CONS))
(EQUAL (CADR BS)
(QUOTE (QUOTE BYTESPEC)))
(LISTP (SETQ TEM (CADDR BS)))
(EQ (CAR TEM)
(QUOTE LIST)))
then (* What a crappy thing to do in order to try to
de-compile the expanded form of
(BYTE <size> <position>))
(pop TEM)
(SETQ SIZE (pop TEM))
(SETQ POSITION (pop TEM))
(if (OR (EVALUABLE.CONSTANT.FIXP N)
(AND (ARGS.COMMUTABLEP N SIZE)
(ARGS.COMMUTABLEP N POSITION)
(ARGS.COMMUTABLEP SIZE POSITION)))
then (BQUOTE (LOADBYTE , WORD , POSITION , SIZE))
else (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
(DECLARE (LOCALVARS \Bytesize \Byteposition))
(LOADBYTE , WORD \Byteposition \Bytesize))
, SIZE , POSITION)))
elseif (AND (LITATOM BS)
(OR (EVALUABLE.CONSTANT.FIXP N)
(ARGS.COMMUTABLEP BS N)))
then (BQUOTE (LOADBYTE , WORD (BYTEPOSITION , BS)
(BYTESIZE , BS)))
else (BQUOTE ((LAMBDA (\PositionSize)
(DECLARE (LOCALVARS \PositionSize))
(LOADBYTE , WORD (BYTEPOSITION \PositionSize)
(BYTESIZE \PositionSize)))
, BS))))))))
(\DPBEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 20:49")
(PROG ((NEWBYTE (CAR X))
(BS (LISPFORM.SIMPLIFY (CADR X)
T))
(WORD (LISPFORM.SIMPLIFY (CADDR X)
T))
SIZE POS X Y BagBiterP N BYTEFORM DEPOSITFORM CBSP TEM)
(if (AND (LISTP BS)
(EQ (CAR BS)
(QUOTE CONS))
(EQUAL (CADR BS)
(QUOTE (QUOTE BYTESPEC)))
(LISTP (SETQ TEM (CADDR BS)))
(EQ (CAR TEM)
(QUOTE LIST)))
then (* What a crappy thing to do in order to try to
de-compile the expanded form of
(BYTE <size> <position>))
(pop TEM)
(SETQ SIZE (pop TEM))
(SETQ POS (pop TEM))
(SETQ CBSP (AND (EVALUABLE.CONSTANTP SIZE)
(EVALUABLE.CONSTANTP POS)))
elseif (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
(type? BYTESPEC TEM))
then (SETQ SIZE (KWOTE (BYTESIZE TEM)))
(SETQ POS (KWOTE (BYTEPOSITION TEM)))
(SETQ CBSP T))
(SETQ N (LISPFORM.SIMPLIFY NEWBYTE T))
(SETQ BagBiterP (OR (NOT (ARGS.COMMUTABLEP N WORD))
(AND (NOT CBSP)
(NOT (ARGS.COMMUTABLEP N BS)))))
(SETQ BYTEFORM (if BagBiterP
then (QUOTE \NewByte)
else NEWBYTE))
(SETQ DEPOSITFORM (if (AND SIZE POS)
then (* the SIZE and POSITION specifiers are somehow
extractable.)
(if (OR CBSP (AND (ARGS.COMMUTABLEP SIZE POS)
(ARGS.COMMUTABLEP WORD BS)))
then (* Case with a detected constant for bytespecifier)
(BQUOTE (DEPOSITBYTE , WORD , POS , SIZE , BYTEFORM))
else (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
(DECLARE (LOCALVARS \Bytesize \Byteposition))
(DEPOSITBYTE , WORD \Byteposition \Bytesize ,
BYTEFORM))
, SIZE , POS)))
else (if (AND (LITATOM BS)
(ARGS.COMMUTABLEP WORD BS))
then (BQUOTE (DEPOSITBYTE , WORD (BYTEPOSITION , BS)
(BYTESIZE , BS)
, BYTEFORM))
else (SETQ BagBiterP T)
(BQUOTE ((LAMBDA (\ByteSpec)
(DECLARE (LOCALVARS \ByteSpec))
(DEPOSITBYTE , WORD (BYTEPOSITION \ByteSpec)
(BYTESIZE \ByteSpec)
\NewByte))
, BS)))))
(RETURN (if BagBiterP
then (BQUOTE ((LAMBDA (\NewByte)
(DECLARE (LOCALVARS \NewByte))
, DEPOSITFORM)
, NEWBYTE))
else DEPOSITFORM)))))
(\LOADBYTEEXPANDER
(LAMBDA (X) (* JonL "20-SEP-83 15:14")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (BQUOTE (LOGAND (LRSH , (CAR X)
, POS)
(MASK.1'S 0 , (CADDR X))))
else (QUOTE IGNOREMACRO)))
(EVALUABLE.CONSTANT.FIXP (CADR X)))
else (if (OR (NOT (\INDEXABLE.FIXP SIZE))
(NOT (IGEQ SIZE 0)))
then (ERROR (CADDR X)
"Byte size out of range"))
(if (ZEROP SIZE)
then (LIST (QUOTE PROGN)
(CAR X)
(CADR X)
0)
else (PROG ((WORD (CAR X))
(POS (CADR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE))
else (LOGXOR -1 (LLSH -1 SIZE))))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
then (* The position is constant)
(if (OR (NOT (\INDEXABLE.FIXP TEM))
(NOT (IGEQ TEM 0)))
then (ERROR POS "Byte position out of range"))
(SETQ POS TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
then (RETURN (LOADBYTE TEM POS SIZE))))
(RETURN (LIST (QUOTE LOGAND)
(if (ZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "20-SEP-83 20:31")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (ZEROP SIZE)
then (LIST (QUOTE PROG1)
(CAR X)
(CADR X)
(CADDDR X))
else (ERROR (CADDR X)
"Byte size out of range"))
elseif (AND POS (ILESSP POS 0))
then (ERROR (CADR X)
"Byte position out of range")
elseif (OR (NULL SIZE)
(NULL POS)
NIL)
then (* Unless both Position and Size are constant, then the
open-coded formula has too much likelihood of CONSing)
(QUOTE IGNOREMACRO)
else (PROG ((WORD (CAR X))
(VAL (CADDDR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE))
else (LOGXOR -1 (LLSH -1 SIZE))))
NWORD NVAL)
(SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
(AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
(SETQ NVAL (LOGAND NVAL MASK)))
(RETURN (if (AND NWORD NVAL)
then (\XDEPOSITBYTE NWORD POS SIZE NVAL)
elseif NWORD
then (* So VAL is now know not to be numeric
(or else the preceeding clause would have been taken))
((LAMBDA (SHIFTEDVAL)
(if (NEQ POS 0)
then (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
SHIFTEDVAL POS)))
(if (ZEROP (SETQ NWORD (BITCLEAR NWORD (LLSH MASK POS))))
then SHIFTEDVAL
else (LIST (QUOTE LOGOR)
NWORD SHIFTEDVAL)))
(LIST (QUOTE LOGAND)
VAL MASK))
else ((LAMBDA (MWORD)
(if (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
then (* Depositing a byte of 0's)
MWORD
elseif (AND NVAL (EQ MASK NVAL))
then (* Depositing a byte of 1'S)
(CONS (QUOTE BITSET)
(CDR MWORD))
else (if NVAL
then (SETQ VAL (LLSH NVAL POS))
else (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
(if (NOT (ZEROP POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(BQUOTE (LOGOR , MWORD , VAL))))
(BQUOTE (BITCLEAR , WORD , (LLSH MASK POS)))))))))
(EVALUABLE.CONSTANT.FIXP (CADR X))
(EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(* Grumble lossaged due to failure of (FNS ...) when merely EVAL@COMPILE)
(DEFINEQ
(\SETUP.MASKARRAYS
(LAMBDA NIL (* JonL "22-JAN-83 22:58")
(* \RJ1M is a Vector of right-justified 1's masks.
\MASKOUT.MARGIN is a 2-dim Vector of 1's masks, in all
possible alignments in a cell.)
(SETQ \RJ1M (\MakeVector (ADD1 BITS.PER.FIXP)))
(\VectorSET \RJ1M BITS.PER.FIXP -1)
(for K from 0 to (PROG1 (SUB1 BITS.PER.FIXP) (* Comment PPLossage)
)
do (\VectorSET \RJ1M K (SUB1 (LLSH 1 K))))
(SETQ \MASKOUT.MARGIN (\MakeVector (ADD1 BITS.PER.FIXP)))
(* Each element of \MASKOUT.MARGIN is a vector of masks,
where increasing indices means increasing start-position
of the mask.)
(\VectorSET \MASKOUT.MARGIN 0 \RJ1M)
(for POS from 1 to BITS.PER.FIXP bind MASKARRAY MAXFIELDSIZE
do (SETQ MAXFIELDSIZE (IDIFFERENCE BITS.PER.FIXP POS))
(SETQ MASKARRAY (\MakeVector (ADD1 MAXFIELDSIZE)))
(for K from 0 to (PROG1 MAXFIELDSIZE (* Comment PPLossage))
do (\VectorSET MASKARRAY K (LLSH (\VectorREF \RJ1M K)
POS)))
(\VectorSET \MASKOUT.MARGIN POS MASKARRAY))))
(\MASK.1'S.EXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
then (SETQ POSITION TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
then (SETQ SIZE TEM)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
SIZE))
elseif (ZEROP POSITION)
then (RETURN (LIST (QUOTE \VectorREF)
(QUOTE \RJ1M)
SIZE))))
(RETURN (LIST (QUOTE \VectorREF)
(LIST (QUOTE \VectorREF)
(QUOTE \MASKOUT.MARGIN)
POSITION)
SIZE)))))
(\LOADBYTEEXPANDER
(LAMBDA (X) (* JonL "20-SEP-83 15:14")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (BQUOTE (LOGAND (LRSH , (CAR X)
, POS)
(MASK.1'S 0 , (CADDR X))))
else (QUOTE IGNOREMACRO)))
(EVALUABLE.CONSTANT.FIXP (CADR X)))
else (if (OR (NOT (\INDEXABLE.FIXP SIZE))
(NOT (IGEQ SIZE 0)))
then (ERROR (CADDR X)
"Byte size out of range"))
(if (ZEROP SIZE)
then (LIST (QUOTE PROGN)
(CAR X)
(CADR X)
0)
else (PROG ((WORD (CAR X))
(POS (CADR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE))
else (LOGXOR -1 (LLSH -1 SIZE))))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
then (* The position is constant)
(if (OR (NOT (\INDEXABLE.FIXP TEM))
(NOT (IGEQ TEM 0)))
then (ERROR POS "Byte position out of range"))
(SETQ POS TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
then (RETURN (LOADBYTE TEM POS SIZE))))
(RETURN (LIST (QUOTE LOGAND)
(if (ZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "20-SEP-83 20:31")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (ZEROP SIZE)
then (LIST (QUOTE PROG1)
(CAR X)
(CADR X)
(CADDDR X))
else (ERROR (CADDR X)
"Byte size out of range"))
elseif (AND POS (ILESSP POS 0))
then (ERROR (CADR X)
"Byte position out of range")
elseif (OR (NULL SIZE)
(NULL POS)
NIL)
then (* Unless both Position and Size are constant, then the
open-coded formula has too much likelihood of CONSing)
(QUOTE IGNOREMACRO)
else (PROG ((WORD (CAR X))
(VAL (CADDDR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (LRSH -1 (IDIFFERENCE BITS.PER.FIXP SIZE))
else (LOGXOR -1 (LLSH -1 SIZE))))
NWORD NVAL)
(SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
(AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
(SETQ NVAL (LOGAND NVAL MASK)))
(RETURN (if (AND NWORD NVAL)
then (\XDEPOSITBYTE NWORD POS SIZE NVAL)
elseif NWORD
then (* So VAL is now know not to be numeric
(or else the preceeding clause would have been taken))
((LAMBDA (SHIFTEDVAL)
(if (NEQ POS 0)
then (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
SHIFTEDVAL POS)))
(if (ZEROP (SETQ NWORD (BITCLEAR NWORD (LLSH MASK POS))))
then SHIFTEDVAL
else (LIST (QUOTE LOGOR)
NWORD SHIFTEDVAL)))
(LIST (QUOTE LOGAND)
VAL MASK))
else ((LAMBDA (MWORD)
(if (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
then (* Depositing a byte of 0's)
MWORD
elseif (AND NVAL (EQ MASK NVAL))
then (* Depositing a byte of 1'S)
(CONS (QUOTE BITSET)
(CDR MWORD))
else (if NVAL
then (SETQ VAL (LLSH NVAL POS))
else (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
(if (NOT (ZEROP POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(BQUOTE (LOGOR , MWORD , VAL))))
(BQUOTE (BITCLEAR , WORD , (LLSH MASK POS)))))))))
(EVALUABLE.CONSTANT.FIXP (CADR X))
(EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DOCOPY
(\SETUP.MASKARRAYS)
)
(* Primitive functions, especially needed for CommonLisp array package.)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETBASE 10MACRO (= . \GETBASEFIXP))
(PUTPROPS \PUTBASE 10MACRO (= . \PUTBASEFIXP))
(PUTPROPS \GETBASEPTR 10MACRO (OPENLAMBDA (BASE OFFST)
(VAG (LRSH (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 1)))
(COND ((ODDP OFFST)
0)
(T 18))))))
(PUTPROPS \PUTBASEPTR 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(* The reason for this kludgy duplication is so that the 10
compiler can open-code the arithmetic)
(CLOSER (IPLUS (LOC BASE)
(LRSH OFFST 1))
(DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 1)))
(COND ((ODDP OFFST)
0)
(T 18))
18
(LOC VAL)))
VAL))
(PUTPROPS \GETBASEFIXP 10MACRO ((BASE OFFST)
(OPENR (IPLUS (LOC BASE)
OFFST))))
(PUTPROPS \PUTBASEFIXP 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(CLOSER (IPLUS (LOC BASE)
OFFST)
VAL)
VAL))
(PUTPROPS \GETBASEFLOATP 10MACRO ((BASE OFFST)
(fetch FLONUM of (VAG (IPLUS (LOC BASE)
OFFST)))))
(PUTPROPS \PUTBASEFLOATP 10MACRO ((BASE OFFST VAL)
(replace FLONUM of (VAG (IPLUS (LOC BASE)
OFFST))
with VAL)))
(PUTPROPS \GETBASEDOUBLEBYTE 10MACRO (OPENLAMBDA (BASE OFFST)
(LOADBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 1)))
(COND ((ODDP OFFST)
4)
(T 20))
16)))
(PUTPROPS \PUTBASEDOUBLEBYTE 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(CLOSER (IPLUS (LOC BASE)
(LRSH OFFST 1))
(DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 1)))
(COND ((ODDP OFFST)
4)
(T 20))
16 VAL))))
(PUTPROPS \GETBASEBYTE 10MACRO (OPENLAMBDA (BASE OFFST)
(* Crufty way to pack 4 8-bit bytes into a 36-bit word,
with 4 bits left over)
(LOADBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 2)))
(IPLUS 4 (LLSH (IDIFFERENCE 3 (LOGAND OFFST 3))
3))
8)))
(PUTPROPS \PUTBASEBYTE 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(CLOSER (IPLUS (LOC BASE)
(LRSH OFFST 2))
(DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 2)))
(IPLUS 4
(LLSH (IDIFFERENCE
3
(LOGAND OFFST 3))
3))
8 VAL))))
(PUTPROPS \GETBASENIBBLE 10MACRO (OPENLAMBDA (BASE OFFST)
(LOADBYTE (OPENR (IPLUS (LOC BASE)
(IQUOTIENT OFFST 9)))
(LLSH (IDIFFERENCE 8 (IREMAINDER OFFST 9))
2)
4)))
(PUTPROPS \PUTBASENIBBLE 10MACRO (OPENLAMBDA (BASE OFFST VAL)
(CLOSER (IPLUS (LOC BASE)
(IQUOTIENT OFFST 9))
(DEPOSITBYTE (OPENR (IPLUS (LOC BASE)
(IQUOTIENT OFFST 9)))
(LLSH (IDIFFERENCE 8
(IREMAINDER
OFFST 9))
2)
4 VAL))))
(PUTPROPS \GETBASEBIT 10MACRO (OPENLAMBDA (BASE OFFST)
(COND ((BITTEST (OPENR (IPLUS (LOC BASE)
(IQUOTIENT OFFST 36)))
(LRSH -34359738368 (IREMAINDER OFFST 36)))
1)
(T 0))))
(PUTPROPS \PUTBASEBIT 10MACRO (OPENLAMBDA (BASE OFFST VAL)
((LAMBDA (Bit1P)
(DECLARE (LOCALVARS Bit1P))
(COND ((COND ((ZEROP VAL)
Bit1P)
(T (NOT Bit1P)))
(CLOSER (IPLUS (LOC BASE)
(IQUOTIENT OFFST 36))
(LOGXOR (OPENR (IPLUS (LOC BASE)
(IQUOTIENT
OFFST 36)))
(LRSH (LLSH 1 35)
(IREMAINDER OFFST 36))
))))
(COND (Bit1P 1)
(T 0)))
(BITTEST (OPENR (IPLUS (LOC BASE)
(IQUOTIENT OFFST 36)))
(LRSH -34359738368 (IREMAINDER OFFST 36))))))
)
)
(DEFINEQ
(\GETBASE
(LAMBDA (BASE OFFST)
(\MACRO.MX (\GETBASE BASE OFFST))))
(\PUTBASE
(LAMBDA (BASE OFFST VAL) (* JonL "13-SEP-83 10:52")
(\MACRO.MX (\PUTBASE BASE OFFST VAL))))
(\GETBASEPTR
(LAMBDA (BASE OFFST)
(\MACRO.MX (\GETBASEPTR BASE OFFST))))
(\PUTBASEPTR
(LAMBDA (BASE OFFST VAL)
(\MACRO.MX (\PUTBASEPTR BASE OFFST VAL))))
(\GETBASEFIXP
(LAMBDA (BASE OFFST) (* JonL "19-OCT-82 20:50")
(\MACRO.MX (\GETBASEFIXP BASE OFFST))))
(\PUTBASEFIXP
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 20:57")
(\MACRO.MX (\PUTBASEFIXP BASE OFFST VAL))))
(\GETBASEFLOATP
(LAMBDA (BASE OFFST) (* JonL " 7-FEB-83 19:41")
(\MACRO.MX (\GETBASEFLOATP BASE OFFST))))
(\PUTBASEFLOATP
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 19:42")
(\MACRO.MX (\PUTBASEFLOATP BASE OFFST VAL))))
(\GETBASEDOUBLEBYTE
(LAMBDA (BASE OFFST)
(\MACRO.MX (\GETBASEDOUBLEBYTE BASE OFFST))))
(\PUTBASEDOUBLEBYTE
(LAMBDA (BASE OFFST VAL)
(\MACRO.MX (\PUTBASEDOUBLEBYTE BASE OFFST VAL))))
(\GETBASEBYTE
(LAMBDA (BASE OFFST) (* JonL "13-SEP-83 18:38")
(PROGN (* Crufty way to pack 4 8-bit bytes into a 36-bit word,
with 4 bits left over)
(LOADBYTE (OPENR (IPLUS (LOC BASE)
(LRSH OFFST 2)))
(IPLUS 4 (LLSH (IDIFFERENCE 3 (LOGAND OFFST 3))
3))
8))))
(\PUTBASEBYTE
(LAMBDA (BASE OFFST VAL)
(\MACRO.MX (\PUTBASEBYTE BASE OFFST VAL))))
(\GETBASENIBBLE
(LAMBDA (BASE OFFST) (* JonL "16-FEB-83 19:45")
(\MACRO.MX (\GETBASENIBBLE BASE OFFST))))
(\PUTBASENIBBLE
(LAMBDA (BASE OFFST VAL) (* JonL "16-FEB-83 19:52")
(\MACRO.MX (\PUTBASENIBBLE BASE OFFST VAL))))
(\GETBASEBIT
(LAMBDA (BASE OFFST) (* JonL "27-JAN-83 20:34")
(\MACRO.MX (\GETBASEBIT BASE OFFST))))
(\PUTBASEBIT
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 21:01")
(\MACRO.MX (\PUTBASEBIT BASE OFFST VAL))))
)
(PUTPROPS NONDADDARITH COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (6204 7198 (\MakeVector 6216 . 6426) (\VectorREF 6430 . 6732) (\VectorSET 6736 . 7064) (
\VectorLength 7068 . 7195)) (9372 10159 (\MASK.1'S.EXPANDER 9384 . 10156)) (10161 11579 (MASK.1'S
10173 . 10645) (MASK.0'S 10649 . 11004) (BITTEST 11008 . 11152) (BITSET 11156 . 11298) (BITCLEAR 11302
. 11448) (LOGNOT 11452 . 11576)) (11581 12989 (\SETUP.MASKARRAYS 11593 . 12986)) (13082 13877 (
LOADBYTE 13094 . 13345) (DEPOSITBYTE 13349 . 13874)) (14807 23532 (\LDBEXPANDER 14819 . 16687) (
\DPBEXPANDER 16691 . 19418) (\LOADBYTEEXPANDER 19422 . 20955) (\DEPOSITBYTEEXPANDER 20959 . 23529)) (
23657 29952 (\SETUP.MASKARRAYS 23669 . 25062) (\MASK.1'S.EXPANDER 25066 . 25838) (\LOADBYTEEXPANDER
25842 . 27375) (\DEPOSITBYTEEXPANDER 27379 . 29949)) (34113 36632 (\GETBASE 34125 . 34207) (\PUTBASE
34211 . 34365) (\GETBASEPTR 34369 . 34457) (\PUTBASEPTR 34461 . 34557) (\GETBASEFIXP 34561 . 34719) (
\PUTBASEFIXP 34723 . 34885) (\GETBASEFLOATP 34889 . 35051) (\PUTBASEFLOATP 35055 . 35221) (
\GETBASEDOUBLEBYTE 35225 . 35327) (\PUTBASEDOUBLEBYTE 35331 . 35441) (\GETBASEBYTE 35445 . 35867) (
\PUTBASEBYTE 35871 . 35969) (\GETBASENIBBLE 35973 . 36135) (\PUTBASENIBBLE 36139 . 36305) (\GETBASEBIT
36309 . 36465) (\PUTBASEBIT 36469 . 36629)))))
STOP